home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / vector.t < prev    next >
Encoding:
Text File  |  1990-06-22  |  7.6 KB  |  213 lines
  1. (herald vector (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; the size is converted to the number of longwords needed, represented as a
  27. ;;; t integer.  coincidentally (?) this is the number of longwords * 4 or
  28. ;;; the number of bytes to cons. we add 4 bytes for the header in size computation.
  29. ;;; vector types are limited to 23 bits for the number of elements
  30.  
  31. ;(define-constant MAXIMUM-VECTOR-SIZE (fx- (fixnum-ashl 1 24) 1)) ; bootstrap?!
  32.                                                                 
  33. ;;; the MAXIMUM-VECTOR-SIZE is 23 bits.
  34. (define-constant (acceptable-vector-size? i)   
  35.   (and (fixnum? i) (fx>= i 0) (fx<= i 16777215)))
  36.  
  37. (define (make-bytev length)
  38.   (let ((length (enforce acceptable-vector-size? length)))
  39.     (make-vector-extend header/bytev length (fixnum-ashr (fx+ length 3) 2))))
  40.  
  41. (define (make-text length)
  42.   (let ((length (enforce acceptable-vector-size? length)))
  43.     (make-vector-extend header/text length (fixnum-ashr (fx+ length 3) 2))))
  44.  
  45. (define (make-vector length . fill)
  46.   (let ((vec (make-vector-extend header/general-vector
  47.                      (enforce acceptable-vector-size? length)
  48.                      length)))
  49.     (if (pair? fill) (vector-fill vec (car fill)))
  50.     vec))
  51.  
  52. (define (make-unit length)
  53.   (make-vector-extend header/unit
  54.                      (enforce acceptable-vector-size? length)
  55.                      length))
  56.  
  57. (define (make-vcell id)
  58.   (let ((v (make-vector-extend header/vcell 0 %%vcell-size)))
  59.     (set (mref-integer v 0) header/nonvalue)
  60.     (set (vcell-locations v) (make-weak-alist))
  61.     (set (vcell-vcell-locations v) (make-weak-alist))
  62.     (set (vcell-id v) id)
  63.     v))
  64.  
  65. (define (make-foreign name)
  66.   (let ((x (make-vector-extend header/foreign 0 2)))
  67.     (set (foreign-name x) name)
  68.     x))
  69.   
  70. (define (vector-replace target source len)
  71.   (let ((target (enforce vector? target))
  72.         (source (enforce vector? source))
  73.         (len (enforce nonnegative-fixnum? len)))
  74.     (%copy-extend target source len)))
  75.  
  76. (define (copy-vector vector)            
  77.   (%copy-vector (enforce vector? vector)))
  78.  
  79. (define (copy-bytev bytev)
  80.   (%copy-bytev (enforce bytev? bytev)))
  81.            
  82. (define (copy-text text)
  83.   (%copy-text (enforce text? text)))
  84.  
  85. (define (vector . elements) (list->vector elements))
  86.  
  87. (define (list->vector l)
  88.   (let ((l (enforce list? l)))
  89.   (let ((len (length l)))
  90.     (let ((vec (make-vector len)))
  91.       (do ((i 0 (fx+ i 1))
  92.            (l l (cdr l)))
  93.           ((fx= i len) vec)
  94.         (set (vref vec i) (car l)))))))
  95.  
  96. (define (vector->list v)
  97.   (let ((v (enforce vector? v)))
  98.     (do ((i (fx- (vector-length v) 1) (fx- i 1))
  99.          (l '() (cons (vref v i) l)))
  100.         ((fx< i 0) l))))
  101.  
  102. (define (vector-pos pred thing vector)
  103.   (let ((len (vector-length vector)))
  104.     (iterate loop ((i 0))
  105.       (cond ((fx>= i len) nil)
  106.             ((pred thing (vref vector i)) i)
  107.             (else (loop (fx+ i 1)))))))
  108.  
  109. (define-integrable (vector-posq thing vector) (vector-pos eq? thing vector))
  110.  
  111. (define (walk-vector fn vec)
  112.   (let ((vec (enforce vector? vec)))
  113.     (let ((limit (fx- (vector-length vec) 1)))
  114.       (cond ((fx>= limit 0)
  115.              (iterate loop ((i 0))
  116.                (cond ((fx>= i limit) 
  117.                       (fn (vref vec i)))
  118.                      (else
  119.                       (fn (vref vec i))
  120.                       (loop (fx+ i 1))))))))))
  121.  
  122.  
  123. (define (%copy-vector vector)
  124.   (let ((len (vector-length vector)))
  125.     (%copy-extend (make-vector len) vector len)))  
  126.  
  127. (define (%copy-bytev bytev)
  128.   (let ((len (bytev-length bytev)))
  129.     (%copy-extend (make-bytev len)
  130.                   bytev
  131.                   (fixnum-ashr (fx+ len 3) 2))))
  132.  
  133. (define (%copy-text text)
  134.   (let ((len (text-length text)))
  135.     (%copy-extend (make-text len)
  136.                   text
  137.                   (fixnum-ashr (fx+ len 3) 2))))
  138.  
  139. (define (%copy-extend dest source cells)
  140.   (do ((i 0 (fx+ i 1)))
  141.       ((fx= i cells) dest)
  142.     (set (extend-elt dest i) (extend-elt source i))))
  143.  
  144. (define (vector-fill vector value)      
  145.   (let ((size (vector-length vector)))  
  146.     (do ((i 0 (fx+ i 1)))
  147.         ((fx>= i size) vector)
  148.       (set (vref vector i) value))))
  149.  
  150. (define-handler general-vector
  151.   (object nil
  152.     ((hash self)
  153.      (do ((i 0 (fx+ i 1))
  154.           (h 0 (fx+ h (hash (vref self i)))))
  155.          ((fx>= h (vector-length self)) h)))
  156.     ((crawl-exhibit self)
  157.      (exhibit-standard-extend self (vector-length self) 0 0))
  158.     ((maybe-crawl-component self command)
  159.      (cond ((and (nonnegative-fixnum? command)
  160.                  (fx< command (vector-length self)))
  161.             (crawl-push (vref self command)))
  162.            (else nil)))
  163.     ((print obj port)
  164.      (write-char port *dispatch-char*)
  165.      (write-char port *list-begin-char*)
  166.      (iterate loop ((flag nil)
  167.                     (i 0))
  168.        (cond ((fx>= i (vector-length obj)))
  169.              (else
  170.               (if flag (space port))
  171.               (cond ((fx>= i *print-length*)
  172.                      (write-string port print-length-excess))
  173.                     (else
  174.                      (print (vref obj i) port)
  175.                      (loop t (fx+ i 1)))))))
  176.      (write-char port *list-end-char*))))
  177.  
  178. (define (*define-accessor name type offset)
  179.   (let ((the-setter (lambda (x v)
  180.               (let ((x (enforce type x)))
  181.             (set (extend-pointer-elt x offset) v)))))
  182.     (object (lambda (x)          
  183.           (let ((x (enforce type x)))
  184.         (extend-pointer-elt x offset)))
  185.       ((setter self) the-setter)
  186.       ((identification self) name))))
  187.  
  188. (define-operation (unguarded-accessor accessor))
  189.  
  190. (define (*define-vector-accessor name type fetch store)
  191.   (let ((the-setter (lambda (x i v)
  192.               (cond ((not (type x))
  193.                  (error "~s answered false to ~s" x (identification type)))
  194.                 ((or (fixnum-less? i 0)
  195.                  (fixnum-not-less? i (vector-length x)))
  196.                  (error "~s index out of range"
  197.                     (list 'set (list name x i) v)))
  198.                 (else
  199.                  (store x i v))))))
  200.     (object (lambda (x i)
  201.           (cond ((not (type x))
  202.              (error "~s answered false to ~s" x (identification type)))
  203.             ((or (fixnum-less? i 0)
  204.              (fixnum-not-less? i (vector-length x)))
  205.              (error "~s index out of range"
  206.                 (list name x i)))
  207.             (else
  208.              (fetch x i))))
  209.       ((setter self) the-setter)
  210.       ((identification self) name)
  211.       ((unguarded-accessor self) fetch))))
  212.  
  213.